00100	C**** PACKMS.F4 -- TO PACK TOGETHER MANY MS PROGRAM FILES *****
00200	C LOAD WITH [NEW,LCS] MSSIO.FAI,STUF.FAI
00300		DIMENSION NAMES(635),JEXT(200),JREC(235),
00400		1 FIRST(128),V(2000),SECOND(4000),INP(72)
00500	C JREC(235) HAS 34 WDS FREE FOR MISC. INFO
00600		EQUIVALENCE(JWDS,FIRST(19)),(KREC,JREC(202)),(JEXT,NAMES(201))
00700		1 ,(JREC,NAMES(401)),(JFLAG,FIRST(128))
00800		IREC=1
00900		JREC(1)=6
01000	15	FORMAT(' P(ACK), U(NPACK), D(IRECTORY)?  '$)
01100	18	TYPE 15
01200		ACCEPT 1,JWDS,K,L
01300		IPU=0
01400		MORE=0
01500		IF(JWDS.EQ.'P')GO TO 2
01600		INF=-1
01700		IPU=-1
01800		IF(JWDS.EQ.'D')	IPU=-IPU
01900	C PACK=0,  UNPACK=-1, DIRECTORY=1
02000	16	FORMAT(' TYPE PACK FILE NAME AND EXT.(DEFAULT EXT=.PAK)  '$)
02100	17	TYPE 16
02200		ACCEPT 1,INP
02300		X=' '
02400		CALL NAMEXT(INP,IPAK,X)
02500		IF(INP(1).EQ.' ')IPAK=JPAK
02600		JPAK=IPAK
02700		IF(X.EQ.' ')X='PAK'
02800		IF(LOOKX(IPAK,X).EQ.0)GO TO 17
02900		IF(IPU.GT.0)GO TO 113
03000	1	FORMAT(72A1)
03100	2	IF(IPU.LT.0)GO TO 41
03200		TYPE 3
03300		GO TO 42
03400	41	TYPE 40
03500	3	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS)  '$)
03600	40	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS) OR "ALL"  '$)
03700	4	FORMAT(' TYPE LAST NAME OR "ALL" (NO EXT, <CR>=1 FILE ONLY)  '$)
03800	42	ACCEPT 1,INP
03900		KEXT=' '
04000		CALL NAMEXT(INP,NAME,KEXT)
04100		IF(KEXT.EQ.' ')KEXT='MS'
04200		IF(IPU.LT.0.AND.NAME.EQ.'ALL')GO TO 122
04300		IF(IPU.LT.0)GO TO 19
04400		IF(LOOKX(NAME,KEXT).EQ.0)GO TO 2 
04500	19	TYPE 4
04600		ACCEPT 1,INP
04700		NAME2=' '
04800		X2=' '
04900		CALL NAMEXT(INP,NAME2,X2)
05000		IF(NAME2.EQ.' ')NAME2=NAME
05100		IF(X2.EQ.' ')X2=KEXT
05200		IF(X2.NE.KEXT)GO TO 18
05300		IF(IPU.LT.0)GO TO 121
05400		IF(NAME2.EQ.'ALL')NAME2='99999'
05500	12	IF(MORE.LT.0)GO TO 21
05600		TYPE 16
05700		ACCEPT 1,INP
05800		X=' '
05900		CALL NAMEXT(INP,IPAK,X)
06000		IF(X.EQ.' ')X='PAK'
06100	13	IF(LOOKX(IPAK,X).EQ.0)GO TO 10
06200		TYPE 11
06300	11	FORMAT(' WRITE OVER THAT NAME?  '$)
06400		ACCEPT 1,INP
06500		IF(INP(1).NE.'Y')GO TO 12
06600	10	CALL PUTEXT(IPAK,X)
06700		CALL EXTOUT(NAMES,635)
06800	C COME BACK AND FILL UP THE HEADER LATER.
06900	21	NM=NAME
07000		MORE=0
07100	20	NMX=NM
07200		NMZ=NM
07300	6	IF(LOOKX(NM,KEXT).EQ.0)GO TO 1000
07400	C JUMP IF NOT FOUND
07500	7	CALL GETEXT(NM,KEXT)
07600		CALL EXTIN(FIRST,128)
07700		CALL EXTIN(SECOND,JWDS)
07750		CALL STUFIT(SECOND,JWDS)
07775	C  GO MAKE PACKED VERSION OF DATA
07787		JFLAG=-999
07800		CALL EXTOUT(FIRST,128)
07900		CALL EXTOUT(SECOND,JWDS)
08000		TYPE 9,NM,KEXT
08100		NAMES(IREC)=NM
08200		JEXT(IREC)=KEXT
08300		KREC=IREC
08400		IREC=IREC+1
08500		JREC(IREC)=JREC(IREC-1)+2+(JWDS-1)/128
08600	C SAVE FOR USETI
08700		IF(IREC.LT.201)NAMES(IREC)=0
08800	14	IF(NM.EQ.NAME2.OR.IREC.EQ.200)GO TO 2000
08900	C LIMIT OF 200 FILES AT THIS TIME.
09000		NM=NM+2
09100		GO TO 6
09200	1000	NM=NMX+256
09300	C UPDATE 4TH CHAR.  (E.G. AAAAA TO AAABA)
09400		NMX=NM
09500		IF(LOOKX(NM,KEXT).LT.0)GO TO 7
09600		NM=NMZ+32768
09700	C UPDATE 3RD CHAR. (E.G. AAAAA TO AABAA)
09800		NMX=NM
09900		NMZ=NM
10000		IF(LOOKX(NM,KEXT).LT.0)GO TO 7
10100	C NOW ALL DONE.  REBUILD HEADER.
10200	2001	FORMAT(' ADD MORE TO FILE?  '$)
10300	2000	TYPE 2001
10400		ACCEPT 1,K
10500		MORE=-1
10600		IF(K.EQ.'Y')GO TO 2
10700		CALL USTO(1)
10800		CALL EXTOUT(NAMES,635)
10900		CALL FINEXT
11000		TYPE 8,IPAK,X,KREC
11100		CALL EXIT
11200	8	FORMAT(' ***** ALL DONE WRITING ',A5,'.',A3/5XI3,' FILES')
11300	9	FORMAT(1XA5,'.',A3)
11400	122	IPU=4
11500	121	TYPE 111
11600	111	FORMAT(' CHANGE EXTENSION TO -- (<CR>=NO CHANGE)  '$)
11700	112	FORMAT(A3)
11800		ACCEPT 112,NEXT
11900		IF(NEXT.NE.' ')KEXT=NEXT
12000	113	CALL GETEXT(IPAK,X)
12100		CALL EXTIN(NAMES,635)
12200		IF(IPU.LE.0)GO TO 114
12300		GO TO(109,2,118,3000)IPU
12400	118	GO TO 18
12500	115	FORMAT(' TYPE NEW NAME AND EXT.  '$)
12600	119	MEXT=' '
12700		TYPE 115
12800		ACCEPT 1,INP
12900		CALL NAMEXT(INP,NAME2,MEXT)
13000		IF(MEXT.EQ.' ')MEXT=KEXT
13100		NMX=0
13200		DO 116 K=1,200
13300		NN=NAMES(K)
13400		MM=JEXT(K)
13500		IF(NAME.EQ.NN.AND.KEXT.EQ.MM)NMX=K
13600	116	IF(NAME2.EQ.NN.AND.MEXT.EQ.MM)GO TO 117
13700		IF(NMX.NE.0)GO TO 120
13800		TYPE 102
13900		CALL EXIT
14000	120	NAMES(NMX)=NAME2
14100		JEXT(NMX)=MEXT
14200		CALL EXIT
14300	CCCC GO WRITE NEW FORM OF .PAK FILE	GO TO ????
14400	117	TYPE 11
14500		ACCEPT 1,JWDS
14600		IF(JWDS.NE.'Y')GO TO 18
14700	114	NM=NAME
14800		NN=NM
14900	105	DO 101 K=1,200
15000	101	IF(NAMES(K).EQ.NAME)GO TO 108
15100		NAME=NM+256
15200		NM=NAME
15300		DO 107 K=1,200
15400	107	IF(NAMES(K).EQ.NAME)GO TO 108
15500		NAME=NN+32768
15600		NN=NAME
15700		NM=NN
15800		DO 177 K=1,200
15900	177	IF(NAMES(K).EQ.NAME)GO TO 108
16000	106	IF(INF.NE.0)TYPE 102
16100		GO TO 18
16200	102	FORMAT(' FILE NOT FOUND')
16300	108	CALL USTI(JREC(K))
16400		CALL EXTIN(FIRST,128)
16500		CALL EXTIN(SECOND,JWDS)
16550	C READ INTO SECOND ARRAY.  IF JFLAG=-999 THEN UNDO PACKED FORMAT
16600		TYPE 9,NAME,KEXT
16700		INF=0
16800	104	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 103
16900	C IS FILE ALREADY ON DSK?
17000		TYPE 11
17100		ACCEPT 1,K
17200		IF(K.EQ.'Y')GO TO 103
17300		TYPE 3   
17400		ACCEPT 1,INP
17500		CALL NAMEXT(INP,NAME,KEXT)
17600		GO TO 104
17700	103	JF=JFLAG
17712		JFLAG=0
17718		IF(JF.EQ.-999)CALL UNSTUF(SECOND,V,JWDS)
17725		CALL PUTEXT(NAME,KEXT)
17800		CALL EXTOUT(FIRST,128)
17820		IF(JF.EQ.-999)CALL EXTOUT(V,JWDS)
17860		IF(JF.NE.-999)CALL EXTOUT(SECOND,JWDS)
17880	C USE SECOND ARRAY FOR OLD FORMAT
18000		CALL FINEXT
18100		IF(NAME.EQ.NAME2)CALL EXIT
18200		NAME=NAME+2
18300		GO TO 105
18400	3004	FORMAT(3XI3,' FILES'/)
18500	109	TYPE 3004,KREC
18600		 DO 110 K=1,200
18700		IF(NAMES(K).EQ.0)GO TO 18
18800	110	TYPE 9,NAMES(K),JEXT(K)
18900		GO TO 18
19000	3000	DO 3001 K=1,200
19100		NM=NAMES(K)
19200		IF(NM.EQ.0)CALL EXIT
19300		MM=JEXT(K)
19400		IF(NEXT.NE.' ')MM=NEXT
19500		CALL EXTIN(FIRST,128)
19600		CALL EXTIN(SECOND,JWDS)
19700		TYPE 9,NM,MM
19800	3003	IF(LOOKX(NM,MM).EQ.0)GO TO 3002
19900		TYPE 11
20000		ACCEPT 1,L
20100		IF(L.NE.'Y')GO TO 3001
20200	3002	JF=JFLAG
20225		JFLAG=0
20237		IF(JF.EQ.-999)CALL UNSTUF(SECOND,V,JWDS)
20243		CALL PUTEXT(NM,MM)
20300		CALL EXTOUT(FIRST,128)
20387		IF(JF.EQ.-999)CALL EXTOUT(V,JWDS)
20400		IF(JF.NE.-999)CALL EXTOUT(SECOND,JWDS)
20500		CALL FINEXT
20600	3001	CONTINUE
20700		END
20800	
20900		SUBROUTINE NAMEXT(I,NAME,IEXT)
21000	C FINDS NAME.EXT IN A1 STRING
21100		DIMENSION I(1)
21200	
21300		IF(I(1).NE.-1)GO TO 9
21400	C FIRST PASS UP 'G', 'GM', 'RS', ETC.  (=-1)
21500		DO 1 K=1,72
21600	1	IF(I(K).EQ.' ')GO TO 2
21700	C NOW PASS BLANKS
21800	2	J=72
21900		DO 3 J=K+1,72
22000	3	IF(I(J).NE.' ')GO TO 4
22100	C NOW FOUND START OF WORD (UNLESS ALL BLANKS)
22200	4	IF(J.NE.72)GO TO 5
22300		NAME=' '
22400		RETURN
22500	9	J=1
22600	5	DO 6 K=J,72
22700		IF(I(K).EQ.' ')GO TO 7
22800	C JUMP IF NAME ONLY
22900	6	IF(I(K).EQ.'.')GO TO 8
23000	7	CALL PACKX(NAME,I(J))
23100		RETURN
23200	8	CALL RLOOP(I(61),I(J),K-J)
23300		CALL PACKX(NAME,I(61))
23400		CALL PACKX(IEXT,I(K+1))
23500		END
23600	
23700		SUBROUTINE PACKX(NAM,KNM)
23800		DIMENSION KNM(5)
23900		DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
24000		1 , MM/"774000000000/
24100		NAM=0
24200		DO 12 K=5,1,-1
24300		NAM=NAM .OR. (KNM(K) .AND. MM)
24400		IF (K.EQ.1)RETURN
24500	17	IF (NAM.GE.0)GO TO 13
24600		NAM = (( NAM .AND. LL)/KK) .OR. JJ
24700		GO TO 12
24800	13	NAM = NAM / KK
24900	12	CONTINUE
25000		RETURN
25100		END